home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gnu / adainc / s-tatise.adb < prev    next >
Text File  |  1996-01-30  |  10KB  |  341 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                          --
  5. --             S Y S T E M . T A S K _ T I M E R _ S E R V I C E            --
  6. --                                                                          --
  7. --                                  B o d y                                 --
  8. --                                                                          --
  9. --                             $Revision: 1.18 $                             --
  10. --                                                                          --
  11. --       Copyright (c) 1991,1992,1993,1994, FSU, All Rights Reserved        --
  12. --                                                                          --
  13. -- GNARL is free software; you can redistribute it  and/or modify it  under --
  14. -- terms  of  the  GNU  Library General Public License  as published by the --
  15. -- Free Software  Foundation;  either version 2, or (at  your  option)  any --
  16. -- later  version.  GNARL is distributed  in the hope that  it will be use- --
  17. -- ful, but but WITHOUT ANY WARRANTY;  without even the implied warranty of --
  18. -- MERCHANTABILITY  or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. -- eral Library Public License  for more details.  You should have received --
  20. -- a  copy of the GNU Library General Public License along with GNARL;  see --
  21. -- file COPYING.LIB.  If not,  write to the  Free Software Foundation,  675 --
  22. -- Mass Ave, Cambridge, MA 02139, USA.                                      --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with Ada.Calendar.Conv;
  27. --  Used for, Time_To_Stimespec
  28.  
  29. with System.Compiler_Exceptions;
  30. --  Used for, Current_Exception
  31.  
  32. with Ada.Real_Time.Conv;
  33. --  Used for, Time_Span_To_Stimespec
  34. --            Time_To_Stimespec
  35.  
  36. with System.Task_Primitives;
  37. --  Used for, Condition_Variable
  38. --            Lock, Unlock
  39. --            Write_Lock
  40. --            Cond_Signal
  41. --            Initialize_Lock
  42. --            Initialize_Cond
  43. --            Cond_Timed_wait
  44.  
  45. with System.Tasking.Utilities;
  46. --  Used for, Make_Independent
  47.  
  48. with System.Task_Clock;
  49.  
  50. with System.Task_Clock.Machine_Specifics;
  51. --  Used for, Machine_Specifics.Clock
  52.  
  53. with System.Tasking.Protected_Objects;
  54.  
  55. with System.Tasking;
  56.  
  57. with Unchecked_Conversion;
  58.  
  59. with Unchecked_Deallocation;
  60.  
  61. package body System.Task_Timer_Service is
  62.  
  63.    use System.Tasking.Protected_Objects;
  64.    use System.Tasking;
  65.  
  66.    use System.Task_Clock;
  67.    --  Included use clause for comparison operators
  68.  
  69.    function Clock return Stimespec
  70.      renames Task_Clock.Machine_Specifics.Clock;
  71.  
  72.    type Q_Rec;
  73.    type Q_Link is access Q_Rec;
  74.  
  75.    type Q_Rec is record
  76.       S_O      : Signal_Object;
  77.       T        : Task_Clock.Stimespec;    --  wake up time
  78.       Next     : Q_Link;
  79.       Previous : Q_Link;
  80.    end record;
  81.  
  82.    procedure Deallocate_Q_Rec is new
  83.       Unchecked_Deallocation (Q_Rec, Q_Link);
  84.  
  85.    Q_Head : Q_Link := null;
  86.  
  87.  
  88.    Timer_Condition :  Task_Primitives.Condition_Variable;
  89.    Timer_Lock      :  Task_Primitives.Lock;
  90.  
  91.    Stimespec_Day : constant Stimespec := Task_Clock.Time_Of (86400, 0);
  92.    Stimespec_Large : Stimespec := Clock + Stimespec_Day;
  93.    --  This value is used to make Timer.Server to sleep until some entry
  94.    --  comes into the timer queue.
  95.  
  96.    function To_Access is new
  97.      Unchecked_Conversion (System.Address, Protection_Access);
  98.  
  99.    -------------------
  100.    -- Signal_Object --
  101.    -------------------
  102.  
  103.    protected body Signal_Object is
  104.  
  105.       entry Wait when Open is
  106.       begin
  107.          Open := False;
  108.       end Wait;
  109.  
  110.       procedure Signal is
  111.       begin
  112.          Open := True;
  113.       end Signal;
  114.  
  115.       function Wait_Count return integer is
  116.       begin
  117.          return Wait'Count;
  118.       end Wait_Count;
  119.  
  120.    end Signal_Object;
  121.  
  122.    ------------------------
  123.    -- Timer.Time_Enqueue --
  124.    ------------------------
  125.  
  126.    --  ??? This should be a private operation of Timer; this currently
  127.    --      does not work.
  128.  
  129.    procedure Time_Enqueue
  130.      (T : in Task_Clock.Stimespec;
  131.       N : in out Q_Link);
  132.  
  133.    procedure Time_Enqueue
  134.      (T : in Task_Clock.Stimespec;
  135.       N : in out Q_Link)
  136.    is
  137.       Q_Ptr : Q_Link := Q_Head;
  138.       Error : Boolean;
  139.  
  140.    begin
  141.       --  Create a queue entry
  142.  
  143.       N := new Q_Rec;
  144.       N.T := T;
  145.  
  146.       --  If the new element becomes head of the queue, notify Timer Service
  147.  
  148.       if Q_Head = null then
  149.          N.Next := null;
  150.          N.Previous := null;
  151.          Q_Head := N;
  152.          Task_Primitives.Write_Lock (Timer_Lock, Error);
  153.          Task_Primitives.Cond_Signal (Timer_Condition);
  154.  
  155.          --  Signal the timer server to wake up
  156.  
  157.          Task_Primitives.Unlock (Timer_Lock);
  158.  
  159.       elsif N.T < Q_Head.T then
  160.          N.Next := Q_Head;
  161.          N.Previous := null;
  162.          Q_Head.Previous := N;
  163.          Q_Head := N;
  164.          Task_Primitives.Write_Lock (Timer_Lock, Error);
  165.          Task_Primitives.Cond_Signal (Timer_Condition);
  166.  
  167.          --  Signal the timer server to wake up
  168.  
  169.          Task_Primitives.Unlock (Timer_Lock);
  170.  
  171.       else
  172.          --  Place in the middle
  173.  
  174.          while Q_Ptr.Next /= null loop
  175.             if Q_Ptr.Next.T >= N.T then
  176.                N.Next := Q_Ptr.Next;
  177.                N.Previous := Q_Ptr;
  178.                Q_Ptr.Next.Previous := N;
  179.                Q_Ptr.Next := N;
  180.                exit;
  181.             end if;
  182.  
  183.             Q_Ptr := Q_Ptr.Next;
  184.          end loop;
  185.  
  186.          if Q_Ptr.Next = null then
  187.  
  188.             --  Place at the end
  189.  
  190.             N.Next := null;
  191.             N.Previous := Q_Ptr;
  192.             Q_Ptr.Next := N;
  193.          end if;
  194.       end if;
  195.    end Time_Enqueue;
  196.  
  197.    -----------
  198.    -- Timer --
  199.    -----------
  200.  
  201.    protected body Timer is
  202.  
  203.       -------------------
  204.       -- Timer.Service --
  205.       -------------------
  206.  
  207.       procedure Service (T : out Task_Clock.Stimespec) is
  208.          Q_Ptr : Q_Link := Q_Head;
  209.          W     : integer;
  210.       begin
  211.          while Q_Ptr /= null loop
  212.  
  213.  
  214.             if Q_Ptr.T < Clock or else Q_Ptr.S_O.Wait_Count = 0 then
  215.  
  216.                --  Wake up the waiting task
  217.  
  218.                Q_Ptr.S_O.Signal;
  219.  
  220.                --  Remove the entry, case of head entry
  221.  
  222.                if Q_Ptr = Q_Head then
  223.                   Q_Head := Q_Ptr.Next;
  224.  
  225.                   if Q_Head /= null then
  226.                      Q_Head.Previous := null;
  227.                   end if;
  228.  
  229.                --  Case of tail entry
  230.  
  231.                elsif Q_Ptr.Next = null then
  232.                   Q_Ptr.Previous.Next := null;
  233.  
  234.                --  Case of middle entry
  235.  
  236.                else
  237.                   Q_Ptr.Previous.Next := Q_Ptr.Next;
  238.                   Q_Ptr.Next.Previous := Q_Ptr.Previous;
  239.                end if;
  240.             end if;
  241.  
  242.             Q_Ptr := Q_Ptr.Next;
  243.          end loop;
  244.  
  245.          if Q_Head = null then
  246.             T := Stimespec_Large;
  247.          else
  248.             T := Q_Head.T;
  249.          end if;
  250.  
  251.       end Service;
  252.  
  253.       --  ??? The following entries used to all be called Enqueue; the
  254.       --      compiler does not seem to be able to handle overloading
  255.       --      in requeue statements.
  256.  
  257.       --  The following for Enqueue procedure enqueues elements in wake-up time
  258.       --  order using a single timer queue  (time in System.Real_Time.Time)
  259.       entry Enqueue_Time_Span (T : in Real_Time.Time_Span) when true is
  260.          N : Q_Link;
  261.       begin
  262.          Time_Enqueue (Clock +
  263.             Real_Time.Conv.Time_Span_To_Stimespec (T), N);
  264.          requeue N.S_O.Wait with abort;
  265.          Deallocate_Q_Rec (N);
  266.       end Enqueue_Time_Span;
  267.  
  268.       entry Enqueue_Duration (T : in Duration) when true is
  269.          N : Q_Link;
  270.       begin
  271.          Time_Enqueue (Clock + Task_Clock.Duration_To_Stimespec (T), N);
  272.          requeue N.S_O.Wait with abort;
  273.          Deallocate_Q_Rec (N);
  274.       end Enqueue_Duration;
  275.  
  276.       entry Enqueue_Real_Time (T : in Real_Time.Time) when true is
  277.          N : Q_Link;
  278.       begin
  279.          Time_Enqueue (Real_Time.Conv.Time_To_Stimespec (T), N);
  280.          requeue N.S_O.Wait with abort;
  281.          Deallocate_Q_Rec (N);
  282.       end Enqueue_Real_Time;
  283.  
  284.       entry Enqueue_Calendar_Time (T : in Ada.Calendar.Time) when true is
  285.          N : Q_Link;
  286.       begin
  287.          Time_Enqueue (Ada.Calendar.Conv.Time_To_Stimespec (T), N);
  288.          requeue N.S_O.Wait with abort;
  289.          Deallocate_Q_Rec (N);
  290.       end Enqueue_Calendar_Time;
  291.  
  292.    end Timer;
  293.  
  294.    -------------------
  295.    -- Timer_Service --
  296.    -------------------
  297.  
  298.    Next_Wakeup_Time : Task_Clock.Stimespec := Stimespec_Large;
  299.  
  300.    procedure Temp_Init;
  301.    procedure Temp_Wait;
  302.    --  These procedures contain processing that should be local to
  303.    --  Timer_Server---GNAT workaround. ???
  304.  
  305.    procedure Temp_Init is
  306.    begin
  307.       Tasking.Utilities.Make_Independent;
  308.       Task_Primitives.Initialize_Lock (System.Priority'Last, Timer_Lock);
  309.       Task_Primitives.Initialize_Cond (Timer_Condition);
  310.    end Temp_Init;
  311.    procedure Temp_Wait is
  312.       Result           : Boolean;
  313.       Error            : Boolean;
  314.    begin
  315.       Task_Primitives.Write_Lock (Timer_Lock, Error);
  316.       Task_Primitives.Cond_Timed_Wait
  317.         (Timer_Condition, Timer_Lock, Next_Wakeup_Time, Result);
  318.       Task_Primitives.Unlock (Timer_Lock);
  319.    end Temp_Wait;
  320.  
  321.    task Timer_Server is
  322.       pragma Priority (System.Priority'Last);
  323.    end Timer_Server;
  324.  
  325.    task body Timer_Server is
  326.    begin
  327.       Temp_Init;
  328.       loop
  329.          Temp_Wait;
  330.          if Q_Head = null and then Next_Wakeup_Time < Clock then
  331.          --  In the case where current time passes Stimespec_Large
  332.             Stimespec_Large := Stimespec_Large + Stimespec_Day;
  333.             Next_Wakeup_Time := Stimespec_Large;
  334.          else
  335.             Timer.Service (Next_Wakeup_Time);
  336.          end if;
  337.       end loop;
  338.    end Timer_Server;
  339.  
  340. end System.Task_Timer_Service;
  341.